home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / modops.c < prev    next >
C/C++ Source or Header  |  1992-10-27  |  10KB  |  406 lines
  1. /* ******************************************************************** */
  2. /* modops.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Dynamic module manipulation                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, June 1990 
  10.  */
  11.  
  12. #include "funcalls.h"
  13. #include "defs.h"
  14. #include "structs.h"
  15. #include "error.h"
  16. #include "global.h"
  17.  
  18. #include "symboot.h"
  19. #include "allocate.h"
  20. #include "modules.h"
  21. #include "specials.h"
  22. #include "modboot.h"
  23. #include "root.h"
  24. #include "table.h"
  25.  
  26. /* Dynamic module loading... */
  27.  
  28. EUFUN_1( Fn_dynamic_load_module, name)
  29. {
  30.   extern LispObject load_module(LispObject*);
  31.  
  32.   if (!is_symbol(name))
  33.     CallError(stacktop,
  34.           "dynamic-load-module: not a symbolic name",name,NONCONTINUABLE);
  35.  
  36.   EUCALL_1(load_module,name);
  37.  
  38.   return(get_module(stacktop,ARG_0(stackbase)));
  39. }
  40. EUFUN_CLOSE
  41.  
  42. extern LispObject Fn_module_value(LispObject*);
  43.  
  44. EUFUN_2( Fn_dynamic_accessiblep, mod, sym)
  45. {
  46.   if (!is_symbol(sym))
  47.     CallError(stacktop,"dynamic-accessiblep: non-symbol",sym,NONCONTINUABLE);
  48.  
  49.   if (!is_i_module(mod) && !is_c_module(mod))
  50.     CallError(stacktop,"dynamic-accessiblep: non-module",mod,NONCONTINUABLE);
  51.  
  52.   return((module_binding_exists_p(stacktop,mod,sym) ? lisptrue : nil));
  53. }
  54. EUFUN_CLOSE
  55.  
  56. EUFUN_2( Fn_dynamic_access, mod, sym)
  57. {
  58.   if (!is_symbol(sym))
  59.     CallError(stacktop,"dynamic-access: non-symbol",sym,NONCONTINUABLE);
  60.  
  61.   if (!is_i_module(mod) && !is_c_module(mod))
  62.     CallError(stacktop,"dynamic-accessible: non-module",mod,NONCONTINUABLE);
  63.  
  64.   return(EUCALL_2(Fn_module_value,mod,sym));
  65. }
  66. EUFUN_CLOSE
  67.  
  68. EUFUN_1( Fn_get_module, sym)
  69. {
  70.   LispObject val;
  71.  
  72.   if (!is_symbol(sym))
  73.     CallError(stacktop,"get-module: non-symbol",sym,NONCONTINUABLE);
  74.  
  75.   val = get_module(stacktop,sym);
  76.  
  77.   return(val);
  78. }
  79. EUFUN_CLOSE
  80.  
  81. EUFUN_1( Fn_module_name, mod)
  82. {
  83.   if (!is_i_module(mod) && !is_c_module(mod))
  84.     CallError(stacktop,"module-name: not a module",mod,NONCONTINUABLE);
  85.  
  86.   return(mod->I_MODULE.name);
  87. }
  88. EUFUN_CLOSE
  89.  
  90. EUFUN_1( Fn_module_exports, mod)
  91. {
  92.   if (!is_i_module(mod) && !is_c_module(mod))
  93.     CallError(stacktop,"module-exports: not a module",mod,NONCONTINUABLE);
  94.  
  95.   return(mod->I_MODULE.exported_names); /* Should copy... */
  96. }
  97. EUFUN_CLOSE
  98.  
  99. EUFUN_2(Fn_add_module_export, mod, name)
  100. {    
  101.   LispObject xx;
  102.  
  103.   xx=EUCALL_2(Fn_cons,name, mod->I_MODULE.exported_names);
  104.   mod->I_MODULE.exported_names=xx;
  105.   return nil;
  106. }
  107. EUFUN_CLOSE
  108.  
  109. /* Module junk for bytecode interpreter */
  110.  
  111. EUFUN_2(Fn_make_module, name, nbinds )
  112. {
  113.   char *myspace;
  114.   LispObject newmod,tab;
  115.   LispObject binds;
  116.   int i;
  117.  
  118. #ifdef DGC
  119.   myspace=(char *)allocate_nbytes(stacktop,sizeof(MODULE),TYPE_C_MODULE);
  120. #else
  121.   myspace=allocate_space(stacktop,sizeof(MODULE));
  122. #endif
  123.   tab=allocate_table(stacktop,Fn_eq);
  124.  
  125.   newmod=(LispObject) myspace;
  126.   binds=allocate_static_vector(stacktop,intval(nbinds));
  127.  
  128.   for (i=0; i<intval(nbinds); i++)
  129.     {
  130.       vref(binds,i)=nil; /* NULL maybe */
  131.     }
  132.  
  133.   lval_classof(newmod)=Object;
  134.   lval_typeof(newmod)=TYPE_C_MODULE;
  135.   /* hack */
  136. #ifndef DGC
  137.   gcof(newmod)=gcof(nil);
  138. #endif
  139.   newmod->MODULE.name=name;
  140.   newmod->MODULE.imported_modules=nil;
  141.   newmod->MODULE.bindings=tab;
  142.   newmod->MODULE.exported_names=nil;
  143.   newmod->C_MODULE.values=binds;
  144.   newmod->C_MODULE.entry_count=nbinds;
  145.   put_module(stacktop,newmod->MODULE.name,newmod);
  146.  
  147.   return newmod;
  148. }
  149. EUFUN_CLOSE
  150.  
  151. static EUFUN_2(Fn_binding_location,mod,name)
  152. {
  153.   LispObject bind;
  154.  
  155.   bind=GET_BINDING(mod,name);
  156.  
  157.   return (BINDING_VALUE(bind));
  158. }
  159. EUFUN_CLOSE
  160.  
  161. static EUFUN_2(Fn_binding_home,mod,name)
  162. {
  163.   LispObject bind;
  164.  
  165.   bind=GET_BINDING(mod,name);
  166.  
  167.   return (BINDING_HOME(bind));
  168. }
  169. EUFUN_CLOSE
  170.  
  171. static EUFUN_4(Fn_add_import,mod,name,inmod,inname)
  172. {
  173.   LispObject bind;
  174.  
  175.   bind=GET_BINDING(inmod,inname);
  176.  
  177.   IMPORT_BINDING(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*name*/,bind);
  178.   
  179.   return nil;
  180. }
  181. EUFUN_CLOSE
  182.  
  183. EUFUN_3(Fn_add_binding,mod,name,loc)
  184. {
  185.   
  186.   ADD_BINDING(ARG_0(stackbase)/*mod*/,name,loc,nil);
  187.   
  188.   return nil;
  189. }
  190. EUFUN_CLOSE
  191.  
  192. static EUFUN_2(Fn_module_val,mod,n)
  193. {
  194.   return (vref((mod->C_MODULE.values),intval(n)));
  195. }
  196. EUFUN_CLOSE
  197.  
  198. static EUFUN_3(Fn_module_val_setter,mod,n,val)
  199. {
  200.   vref((mod->C_MODULE.values),intval(n))=val;
  201.   
  202.   return nil;
  203. }
  204. EUFUN_CLOSE
  205.  
  206. /* DJB Type hacks */
  207. /* would be real nice if this was a function */
  208. EUFUN_3(Sf_reify_env,mod,env,form)
  209. {
  210.   LispObject lst=nil;
  211.   Env ptr;
  212.   
  213.   ptr=&(env->ENV);
  214.  
  215.   while (ptr!=NULL)
  216.     {
  217.       LispObject xx;
  218.  
  219.       STACK_TMPV(ptr->next);
  220.       STACK_TMP(lst);
  221.       xx=EUCALL_2(Fn_cons,ptr->variable,ptr->value);
  222.       UNSTACK_TMP(lst);
  223.       lst=EUCALL_2(Fn_cons,xx,lst);
  224.       UNSTACK_TMPV(ptr);
  225.     }
  226.   lst=EUCALL_2(Fn_cons,ARG_0(stackbase)->MODULE.name,lst);
  227.   return lst;
  228. }
  229. EUFUN_CLOSE
  230.  
  231. EUFUN_2(Fn_make_function, envlst, body)
  232. {    /* CAR(body) should be an arglist */
  233.  
  234.   LispObject env=NULL;
  235.   LispObject mod;
  236.   LispObject ptr=CDR(envlst);
  237.   
  238.   while(ptr!=nil)
  239.     {
  240.       STACK_TMP(CDR(ptr));
  241.       env=allocate_env(stacktop,CAR(CAR(ptr)),CDR(CAR(ptr)), env);
  242.       
  243.       UNSTACK_TMP(ptr);
  244.     }
  245.   
  246.   STACK_TMP(env);
  247.   mod=get_module(stacktop,CAR(ARG_0(stackbase))/*name*/);
  248.   UNSTACK_TMP(env);
  249.  
  250.   return(EUCALL_3(Sf_lambda,mod,env,ARG_1(stackbase)));
  251. }
  252. EUFUN_CLOSE
  253.  
  254. static EUFUN_1(Fn_function_body, fn)
  255. {
  256.   if (!is_i_function(fn))
  257.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  258.   
  259.   /*Should add the lambda-list! */
  260.   return fn->I_FUNCTION.body;
  261. }
  262. EUFUN_CLOSE
  263.  
  264. EUFUN_1(Fn_function_env, fn)
  265. {
  266.   LispObject lst=nil;
  267.   Env ptr;
  268.   
  269.   if (!is_i_function(fn))
  270.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  271.  
  272.   ptr=fn->I_FUNCTION.env;
  273.  
  274.   while (ptr!=NULL)
  275.     {
  276.       LispObject xx;
  277.  
  278.       STACK_TMPV(ptr->next);
  279.       STACK_TMP(lst);
  280.       xx=EUCALL_2(Fn_cons,ptr->variable,ptr->value);
  281.       UNSTACK_TMP(lst);
  282.       lst=EUCALL_2(Fn_cons,xx,lst);
  283.       UNSTACK_TMPV(ptr);
  284.     }
  285.   lst=EUCALL_2(Fn_cons,(fn->I_FUNCTION.home)->MODULE.name,lst);
  286.   return lst;
  287. }
  288. EUFUN_CLOSE
  289.  
  290. EUFUN_2(Fn_modify_function_env, fn, envlst)
  291. {
  292.   LispObject env=NULL;
  293.   LispObject mod;
  294.   LispObject ptr=CDR(envlst);
  295.   
  296.   if (!is_i_function(fn))
  297.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  298.  
  299.   while(ptr!=nil)
  300.     {
  301.       STACK_TMP(CDR(ptr));
  302.       env=allocate_env(stacktop,CAR(CAR(ptr)),CDR(CAR(ptr)), env);
  303.       
  304.       UNSTACK_TMP(ptr);
  305.     }
  306.   
  307.   STACK_TMP(env);
  308.   mod=get_module(stacktop,CAR(ARG_1(stackbase))/*name*/);
  309.   UNSTACK_TMP(env);
  310.  
  311.   fn->I_FUNCTION.env = &env->ENV;
  312.   fn->I_FUNCTION.home = mod;
  313.  
  314.   return fn;
  315. }
  316. EUFUN_CLOSE
  317.  
  318. /* 
  319.  * Gobbing out a description file
  320.  * 
  321.  * Contains location info of all loaded modules
  322.  */
  323.  
  324. void make_description_file(LispObject *stacktop)
  325. {
  326. #ifdef BCI
  327.   extern LispObject Fn_boot_module_list(LispObject *);
  328.  
  329.   FILE *file;
  330.   LispObject mods,cmods;
  331.   int i=1;
  332.  
  333.   file=fopen("you.mods","w");
  334.   
  335.   mods=Fn_boot_module_list(stacktop);
  336.   mods=CDR(mods);
  337.   fprintf(file,"(\n");
  338.   while (mods!=nil)
  339.     {
  340.       LispObject binds;
  341.       LispObject vals;
  342.       fprintf(file,"(%s %d",stringof(CAR(mods)->MODULE.name->SYMBOL.pname),i);
  343.       binds=EUCALL_1(Fn_table_keys,CAR(mods)->MODULE.bindings);
  344.       vals=EUCALL_1(Fn_table_parameters,CAR(mods)->MODULE.bindings);
  345.       
  346.       while (binds!=nil)
  347.     {
  348.       fprintf(file," (|%s| . %d)",stringof(CAR(binds)->SYMBOL.pname), intval(BINDING_VALUE(CAR(vals))));
  349.       vals=CDR(vals);
  350.       binds=CDR(binds);
  351.     }
  352.       fprintf(file,")\n");
  353.       
  354.       i++;
  355.       mods=CDR(mods);
  356.     }
  357.   fprintf(file,")\n");
  358.   return;
  359. #else /* no bci */
  360.   return;
  361. #endif
  362. }
  363.  
  364. /*
  365.  * Initialisation...
  366.  */
  367.  
  368. #define MODULE_OPERATORS_ENTRIES 19
  369.  
  370. MODULE Module_module_operators;
  371. LispObject Module_module_operators_values[MODULE_OPERATORS_ENTRIES];
  372.  
  373. void initialise_module_operators(LispObject *stacktop)
  374. {
  375.   open_module(stacktop,
  376.           &Module_module_operators,
  377.           Module_module_operators_values,
  378.           "module-operators",
  379.           MODULE_OPERATORS_ENTRIES);
  380.  
  381.   (void) make_module_function(stacktop,
  382.                   "dynamic-load-module",Fn_dynamic_load_module,1);
  383.   (void) make_module_function(stacktop,"dynamic-access",Fn_dynamic_access,2);
  384.   (void) make_module_function(stacktop,
  385.                   "dynamic-accessible-p",Fn_dynamic_accessiblep,2);
  386.   (void) make_module_function(stacktop,"get-module",Fn_get_module,1);
  387.   (void) make_module_function(stacktop,"module-name",Fn_module_name,1);
  388.   (void) make_module_function(stacktop,"module-exports",Fn_module_exports,1);
  389.  
  390.   (void) make_module_function(stacktop,"add-module-export",Fn_add_module_export,2);
  391.   (void) make_module_function(stacktop,"make-module",Fn_make_module,2);
  392.   (void) make_module_function(stacktop,"module-binding-location",Fn_binding_location,2);
  393.   (void) make_module_function(stacktop,"module-binding-home",Fn_binding_home,2);
  394.   (void) make_module_function(stacktop,"add-module-import",Fn_add_import,4);
  395.   (void) make_module_function(stacktop,"add-module-binding",Fn_add_binding,3);
  396.   (void) make_module_function(stacktop,"module-value",Fn_module_val,2);
  397.   (void) make_module_function(stacktop,"module-value-setter",Fn_module_val_setter,3);
  398.   (void) make_module_special(stacktop,"reify-env",Sf_reify_env);
  399.   (void) make_module_function(stacktop,"make-function",Fn_make_function,2);
  400.   (void) make_module_function(stacktop,"function-body",Fn_function_body,1);
  401.   (void) make_module_function(stacktop,"function-env",Fn_function_env,1);
  402.   (void) make_module_function(stacktop,"modify-function-env",Fn_modify_function_env,2);
  403.   close_module();
  404. }
  405.  
  406.